home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / suspend.t < prev   
Text File  |  1989-11-16  |  13KB  |  359 lines
  1. (herald suspend (env tsys))
  2.  
  3. (define-local-syntax (dotimes spec . body)
  4.   (let ((index (car spec))
  5.         (limit (cadr spec)))
  6.     `(do ((,index 0 (fx+ ,index 1)))
  7.          ((fx= ,index ,limit))
  8.        ,@body)))
  9.  
  10.  
  11. (lset *lstate* nil)
  12.                          
  13. (define (system-suspend path experimental?) 
  14.   (suspend top-level-environments path experimental?))
  15.  
  16. (define-structure-type lstate   ;linker state
  17.     pure            
  18.     impure          
  19.     foreign-reloc   
  20.     foreign                     
  21.     symbols                        
  22.     symbol-count
  23.     text-reloc   ;List of relocation items
  24.     data-reloc
  25.     pure-size
  26.     reloc 
  27.     null
  28.     )
  29.                           
  30. (define lp-table-size (fx* 256 1024))
  31.                                            
  32. (define (create-lstate)
  33.   (let ((l (make-lstate)))
  34.     (set (lstate-foreign l) '())
  35.     (set (lstate-pure l) (make-+area))
  36.     (set (lstate-impure l) (make-+area))
  37.     (set (lstate-symbols l) '())
  38.     (set (lstate-symbol-count l) 0)
  39.     (set (lstate-foreign-reloc l) '())
  40.     (set (lstate-text-reloc l) '())
  41.     (set (lstate-data-reloc l) '())
  42.     (set (lstate-reloc l) (make-lp-table lp-table-size 'reloc-table))
  43.     l))
  44.  
  45.  
  46. (define-structure-type +area         ;A.k.a. "heap"
  47.   frontier      ;Address of next available cell
  48.   objects       ;List of objects allocated
  49.   )
  50.  
  51. (let ((master (stype-master +area-stype)))
  52.   (set (+area-frontier    master) 0)
  53.   (set (+area-objects     master) '()))
  54.                               
  55. (*define t-implementation-env '*boot* 
  56.   (lambda (root-process boot-args debug?)
  57.     (ignore debug?)
  58.     (dispatch-init)
  59.     (set (system-global slink/boot-area-base) (make-vector 0))
  60.     (set (system-global slink/initial-impure-base) top-level-environments)
  61.     (set (*value t-implementation-env '**up**) luser-typed-eof-at-top-level)
  62.     (re-initialize-systems)
  63.     (top-level)))
  64.  
  65. (define (omit null args)
  66.   (walk (lambda (arg)
  67.           (set-lp-table-entry (lstate-reloc *lstate*) arg null))
  68.         args))
  69.        
  70. (block (lset *omit-list* 
  71.          (list *the-initial-symbols*
  72.                *the-initial-modules*
  73.                *code-unit-map*
  74.                *boot-env*
  75.                **cont**
  76.                **up**
  77.                **ret**
  78.            **reset**
  79.                bootstrap-env
  80.                boot-adjust-initial-units
  81.                initialize-symbol-table
  82.                make-base-environment
  83.                object-hash-table
  84.                object-unhash-table
  85.                ))
  86.  nil)
  87.  
  88.  
  89. (define (really-suspend object out-spec out-type)                                             
  90.   (format t "~&Suspending ~a ... ~%" out-spec)
  91.   (bind ((*lstate* (create-lstate)))
  92.     (with-open-ports
  93.         ((image (open (filename-with-type (->filename out-spec) out-type) '(out))))
  94.       (omit (set-up-the-slink) (cons *lstate* *omit-list*))
  95.       (modify (system-%link-edit t-system)
  96.           (lambda (x) (fx+ x 1)))
  97.       (vgc object)
  98.       (format t "writing object file~%")
  99.       (set (lstate-pure-size *lstate*) 
  100.            (+area-frontier (lstate-pure *lstate*)))
  101.       (write-link-file image)
  102.       *lstate*)))
  103.  
  104. (define %%stack-size (* 512 1024))
  105.                      
  106.  
  107.  
  108. ;;; Virtual GC
  109.           
  110. (define (vgc obj)
  111.   (cond ((null? obj) (lstate-null *lstate*))
  112.         ((lp-table-entry (lstate-reloc *lstate*) obj))
  113.         ((pair? obj)
  114.          (vgc-pair obj))
  115.         (else
  116.          (let ((header (extend-header obj)))
  117.            (cond ((template-header? header)
  118.                   (vgc-template obj))
  119.                  ((extend? header)
  120.                   (vgc-closure obj header))
  121.                  ((immediate? header)
  122.                   ((vref *suspend-dispatch-vector* 
  123.                          (header-type (extend-header obj)))
  124.                     obj))
  125.                  (else
  126.           (lstate-null *lstate*)))))))
  127.  
  128.  
  129. (define (vgc-pair pair)
  130.   (let* ((heap (lstate-impure *lstate*))
  131.          (addr (+area-frontier heap))
  132.          (desc (object nil
  133.                  ((heap-stored self) (lstate-impure *lstate*))
  134.                  ((heap-offset self) addr)
  135.                  ((write-descriptor self stream)       
  136.                   (write-data stream (fx+ addr tag/pair)))
  137.                  ((write-store self stream)
  138.                   (write-slot (cdr pair) stream)
  139.                   (write-slot (car pair) stream)))))
  140.       (set (+area-frontier heap) (fx+ addr (fx* CELL 2)))
  141.       (push (+area-objects heap) desc)
  142.       (set-lp-table-entry (lstate-reloc *lstate*) pair desc)
  143.       ;;Trace from the cdr first to linearise lists
  144.       (generate-slot-relocation (cdr pair) addr)
  145.       (generate-slot-relocation (car pair) (fx+ CELL addr))
  146.       desc))
  147.  
  148. (define (vgc-template tmplt)
  149.   (vgc-internal-object tmplt 
  150.                        (template-enclosing-object tmplt) 
  151.                        (template-encloser-offset tmplt)))
  152.  
  153. (define (vgc-closure closure template)
  154.   (cond ((template-internal-bit? template)
  155.          (vgc-internal-object closure 
  156.                               (closure-enclosing-object closure)
  157.                               (closure-encloser-offset closure)))
  158.         (else
  159.          (let* ((ptrs (template-pointer-slots template))
  160.                 (size (fx+ ptrs (template-scratch-slots template))))
  161.            (vgc-extend closure ptrs size)))))
  162.                                              
  163.  
  164. (define (vgc-extend obj ptrs size)
  165.   (let* ((heap (lstate-impure *lstate*))
  166.          (addr (+area-frontier heap))
  167.          (desc 
  168.            (if (fx= ptrs size)
  169.                (object nil
  170.                  ((heap-stored self) (lstate-impure *lstate*))
  171.                  ((heap-offset self) addr)
  172.                  ((write-descriptor self stream)
  173.                   (write-data stream (fx+ addr tag/extend)))
  174.                  ((write-store self stream)
  175.                   (do ((i -1 (fx+ i 1)))
  176.                       ((fx= i ptrs) t)
  177.                     (write-slot (extend-elt obj i) stream))))
  178.                (object nil
  179.                  ((heap-stored self) (lstate-impure *lstate*))
  180.                  ((heap-offset self) addr)
  181.                  ((write-descriptor self stream)
  182.                   (write-data stream (fx+ addr tag/extend)))
  183.                  ((write-store self stream)
  184.                   (do ((i -1 (fx+ i 1)))
  185.                       ((fx= i ptrs)
  186.                        (do ((i i (fx+ i 1)))
  187.                            ((fx= i size) t)
  188.                          (write-scratch stream obj i)))
  189.                     (write-slot (extend-elt obj i) stream)))))))
  190.       (set (+area-frontier heap) (fx+ addr (fx+ (fx* CELL size) CELL)))
  191.       (push (+area-objects heap) desc)
  192.       (set-lp-table-entry (lstate-reloc *lstate*) obj desc)
  193.       (do ((i -1 (fx+ i 1))
  194.            (a addr (fx+ a CELL)))
  195.           ((fx= i ptrs) desc)
  196.         (generate-slot-relocation (extend-elt obj i) a))))
  197.   
  198.  
  199. (define (vgc-internal-object obj obj-encloser offset)
  200.   (let ((encloser (vgc obj-encloser)))
  201.     (cond ((lp-table-entry (lstate-reloc *lstate*) obj))
  202.           (else
  203.            (let* ((addr (fx+ (fixnum-ashl offset 2) 
  204.                              (fx+ (heap-offset encloser) tag/extend)))
  205.                   (desc 
  206.                    (if (bytev? obj-encloser)
  207.                        (object nil
  208.                          ((heap-stored self) (lstate-pure *lstate*))
  209.                          ((write-descriptor self stream)
  210.                           (write-int stream addr)))
  211.                        (object nil
  212.                          ((heap-stored self) (lstate-impure *lstate*))
  213.                          ((write-descriptor self stream)
  214.                           (write-data stream addr))))))
  215.              (set-lp-table-entry (lstate-reloc *lstate*) obj desc)
  216.              desc)))))
  217.  
  218. (define (vgc-bytes bytes vlen pure?)
  219.   (let* ((heap (if pure? (lstate-pure *lstate*) (lstate-impure *lstate*)))
  220.          (addr (+area-frontier heap))
  221.          (end-addr (fx+ CELL (fx+ addr vlen)))
  222.          (desc 
  223.            (if pure?
  224.                (object nil
  225.                  ((heap-stored self) (lstate-pure *lstate*))
  226.                  ((heap-offset self) addr)    
  227.                  ((write-descriptor self stream)
  228.                   (write-int stream (fx+ addr tag/extend)))
  229.                  ((write-store self stream)
  230.                   (write-slot (extend-header bytes) stream)
  231.                   (let ((len (bytev-length bytes)))
  232.                     (do ((i 0 (fx+ i 1)))
  233.                         ((fx>= i len)
  234.                          (dotimes (i (fx- (align len 2) len))
  235.                            (vm-write-byte stream 0)))
  236.                       (vm-write-byte stream (bref bytes i))))))
  237.                (object nil
  238.                  ((heap-stored self) (lstate-impure *lstate*))
  239.                  ((heap-offset self) addr)    
  240.                  ((write-descriptor self stream)
  241.                   (write-data stream (fx+ addr tag/extend)))
  242.                  ((write-store self stream)
  243.                   (write-slot (extend-header bytes) stream)
  244.                   (let ((len (bytev-length bytes)))
  245.                     (do ((i 0 (fx+ i 1)))
  246.                         ((fx>= i len)
  247.                          (dotimes (i (fx- (align len 2) len))
  248.                            (vm-write-byte stream 0)))
  249.                       (vm-write-byte stream (bref bytes i)))))))))
  250.     (set (+area-frontier heap) (align end-addr 2))
  251.     (push (+area-objects heap) desc)
  252.     (set-lp-table-entry (lstate-reloc *lstate*) bytes desc)
  253.     desc))
  254.  
  255.  
  256. (define *suspend-dispatch-vector* (make-vector %%number-of-immediate-types))
  257.  
  258. (let ((gc-copiers
  259.       `(
  260.         (,header/text           ,vgc-text)
  261.         (,header/general-vector ,vgc-general-vector)
  262.         (,header/unit           ,vgc-unit)
  263.         (,header/slice          ,vgc-string)
  264.         (,header/symbol         ,vgc-symbol)
  265.         (,header/bytev          ,vgc-bytev)
  266.         (,header/foreign         ,vgc-foreign)
  267.         (,header/template       ,vgc-template)
  268.         (,header/cell           ,vgc-cell)
  269.         (,header/vcell          ,vgc-vcell)
  270.         (,header/bignum         ,vgc-bignum)
  271.         (,header/double-float   ,vgc-double-float)
  272.         (,header/weak-set       ,vgc-weak)
  273.         (,header/weak-alist     ,vgc-weak)
  274.         (,header/weak-table     ,vgc-weak-table)
  275.         (,header/weak-cell      ,vgc-weak-cell)
  276.         )))
  277.   (vector-fill *suspend-dispatch-vector* vgc-error)
  278.   (walk (lambda (x) (set (vector-elt *suspend-dispatch-vector*
  279.                                      (fixnum-ashr (car x) 2))
  280.                          (cadr x)))
  281.         gc-copiers))
  282.  
  283. (define (vgc-error obj)
  284.   (error "Don't know how to vgc ~s" obj))
  285.  
  286. (define (vgc-text text) 
  287.   (vgc-bytes text (text-length text) (pure? text)))
  288.  
  289. (define (vgc-symbol sym)
  290.   (vgc-bytes sym (symbol-length sym) t))
  291.                                                                                   
  292. (define (vgc-bytev bytev)
  293.   (vgc-bytes bytev (bytev-length bytev) (pure? bytev)))
  294.  
  295. (define (vgc-general-vector vec)
  296.   (vgc-extend vec (vector-length vec) (vector-length vec)))
  297.                                                            
  298. (define (vgc-unit unit)
  299.   (unit-snap-links unit)
  300.   (vgc-extend unit (unit-length unit) (unit-length unit)))
  301.                                                            
  302. (define (vgc-string str)              
  303.   (vgc-extend str 1 2))
  304.  
  305. (define (vgc-cell cell)
  306.   (vgc-extend cell 1 1))
  307.  
  308. (define (vgc-vcell vcell)
  309.   (vgc-extend vcell %%vcell-size %%vcell-size))
  310.  
  311. (define (vgc-bignum bignum)
  312.   (vgc-extend bignum 0 (bignum-length bignum)))
  313.  
  314. (define (vgc-double-float d)
  315.   (vgc-extend d 0 2))
  316.  
  317. (define (vgc-weak weak)
  318.   (vgc-extend weak 1 1))
  319.  
  320. (define (vgc-weak-cell weak)
  321.   (let* ((heap (lstate-impure *lstate*))
  322.          (addr (+area-frontier heap))
  323.          (desc (object nil
  324.                  ((heap-stored self) heap)
  325.                  ((heap-offset self) addr)
  326.                  ((write-descriptor self stream)
  327.                   (write-data stream (fx+ addr tag/extend)))
  328.                  ((write-store self stream)
  329.                   (write-slot (extend-elt weak -1) stream)
  330.                   (write-slot nil stream)))))
  331.     (set (+area-frontier heap) (fx+ addr (fx+ (fx* CELL 1) CELL)))
  332.     (push (+area-objects heap) desc)
  333.     (set-lp-table-entry (lstate-reloc *lstate*) weak desc)
  334.     (generate-slot-relocation nil (fx+ addr CELL))
  335.     desc))
  336.  
  337. (define (vgc-weak-table weak)
  338.   (vgc-extend weak 1 2))
  339.  
  340. (define-integrable (align n m)
  341.   (let ((2^m-1 (fx- (fixnum-ashl 1 m) 1)))
  342.     (fixnum-logand (fx+ n 2^m-1) (fixnum-lognot 2^m-1))))
  343.       
  344. (define-operation (heap-stored obj))
  345. (define-operation (heap-offset obj))           
  346. (define-operation (write-descriptor obj stream))
  347. (define-operation (write-store obj stream))
  348.  
  349.  
  350. (define (unit-snap-links unit)
  351.   (let ((len (unit-length unit)))
  352.     (do ((i 0 (fx+ i 1)))
  353.     ((fx>= i len) t)
  354.       (let ((thing (extend-elt unit i)))
  355.     (or (template? thing)
  356.         (not (extend? thing))
  357.         (neq? (extend-header thing) *link-snapper-template*)
  358.         (set (extend-elt unit i) (extend-elt thing 0)))))))
  359.